home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / PowerLisp 1.1 / Library / format.lisp < prev    next >
Encoding:
Text File  |  1994-03-25  |  18.5 KB  |  599 lines  |  [TEXT/ROSA]
  1. ;;;
  2. ;;;        Copyright © 1994 Roger Corman.  All rights reserved.
  3. ;;;
  4. ;;;
  5. ;;;        Common Lisp 'format' function.
  6. ;;;
  7. (in-package :common-lisp)
  8. (provide :format)
  9.  
  10. (defun format (dest control-string &rest arguments)
  11.     (let ((return-value nil))
  12.         ;; check for dest equal to t or nil
  13.         (cond 
  14.             ((null dest) 
  15.              (progn 
  16.                 (setf dest (make-string-output-stream))
  17.                 (setf return-value dest)))
  18.             ((eq dest t) (setf dest *standard-output*)))
  19.         (catch '%format-up-and-out
  20.             (%format-list dest control-string arguments))
  21.         (if return-value (get-output-stream-string return-value))))
  22.  
  23. (defun %format-list (dest control-string arguments)
  24.     ;; scan control string and dispatch to output functions
  25.     (do ((index 0)
  26.          (arg-index 0)
  27.          (length (length control-string))
  28.          (atsign-modifier nil nil)
  29.          (colon-modifier nil nil)
  30.          dispatch-func
  31.          (parameters nil)
  32.          control
  33.          char)
  34.         ((>= index length) arg-index)
  35.         (setf char (char control-string index))
  36.         (if (char= char #\~)
  37.             ;; process directive
  38.             (progn
  39.                 ;; get parameters
  40.                 (incf index)
  41.                 (multiple-value-setq (parameters index) 
  42.                     (%get-params control-string index))
  43.     
  44.                 ;; check for modifiers
  45.                 (dotimes (i 2)
  46.                     (if (>= index length) (return))
  47.                     (setq char (char control-string index))
  48.                     (if (char= char #\@)
  49.                         (setq atsign-modifier t)
  50.                         (if (char= char #\:)
  51.                             (setq colon-modifier t)
  52.                             (return)))
  53.                     (incf index))
  54.  
  55.                 ;; the next character should be the format
  56.                 ;; directive character
  57.                 (if (>= index length)
  58.                     (error "Invalid format directive: ~A" control-string))
  59.                 (setq char (char control-string index))
  60.                 (incf index)
  61.                 (setf dispatch-func 
  62.                     (%get-format-dispatch-func char))
  63.                 (if (null dispatch-func)
  64.                     (error "Invalid format directive : ~A" control-string))
  65.                 (setq control (list control-string index))
  66.                 (setq arg-index 
  67.                     (apply dispatch-func 
  68.                         dest 
  69.                         arguments arg-index 
  70.                         atsign-modifier colon-modifier 
  71.                         control
  72.                         parameters))
  73.                 (setq index (cadr control)))         
  74.  
  75.             ;; just output the character
  76.             (progn
  77.                 (write-char char dest)
  78.                 (incf index)))))
  79.  
  80.  
  81. ;;;
  82. ;;;
  83. ;;;    Returns two values: the list of params found and the
  84. ;;; updated index.
  85. ;;
  86. (defun %get-params (control-string index &aux (params nil))
  87.     (do (int
  88.          c
  89.          (length (length control-string)))
  90.         ((>= index length))
  91.         (if (char= (char control-string index) #\Newline)
  92.             (return))
  93.         (multiple-value-setq (int index) 
  94.             (parse-integer control-string :start index
  95.                 :junk-allowed t))
  96.         (setq c (char control-string index))
  97.         (if int 
  98.             (push int params)
  99.             (if (char= c #\,) 
  100.                 (push nil params)))
  101.         (if (char= c #\,) (incf index) (return)))
  102.     (values (nreverse params) index))
  103.         
  104. ;;; Format dispatch functions take a stream, argument list,
  105. ;;; @-modifier and :-modifier arguments, followed by any passed
  106. ;;; parameters. Any passed parameters which are nil should be
  107. ;;; assumed to be requesting the default. The dispatch functions
  108. ;;; should return the remaining argument list (missing the
  109. ;;; arguments that they processed.
  110. ;;;
  111.  
  112. (defvar *format-functions* #128())
  113.  
  114. (defun %set-format-dispatch-func (char func)
  115.     (let ((index (char-code (char-upcase char))))
  116.         (setf (elt *format-functions* index) func)))
  117.  
  118. (defun %get-format-dispatch-func (char)
  119.     (let ((index (char-code (char-upcase char))))
  120.         (elt *format-functions* index)))
  121.  
  122. (%set-format-dispatch-func #\A 
  123.     #'(lambda (stream args index atsign-modifier colon-modifier control
  124.                 &optional mincol colinc 
  125.                         minpad padchar)
  126.         (setq args (nthcdr index args))
  127.         (if (null args) 
  128.             (error "Not enough args for ~AA format directive" #\~))
  129.  
  130.         ;; initialize defaults
  131.         (unless mincol (setq mincol 0))
  132.         (unless colinc (setq colinc 1))
  133.         (unless minpad (setq minpad 0))
  134.         (setq padchar (if padchar (int-char padchar) #\Space))
  135.  
  136.         (let ((*print-escape* nil)
  137.                 (arg (car args)))
  138.             (if (and (null arg) colon-modifier)
  139.                 (setq arg "()"))
  140.             (if atsign-modifier
  141.                 ;; needto output to string to insert padding in front
  142.                 (let ((s (with-output-to-string (x) (princ arg x))) 
  143.                       length)
  144.                     (dotimes (i minpad) (write-char padchar stream))
  145.                     (setq length (length s))
  146.                      (incf length minpad)
  147.                     (do ()
  148.                         ((>= length mincol))
  149.                         (dotimes (i colinc) (write-char padchar stream))
  150.                         (incf length colinc))
  151.                     (princ s stream))
  152.                 (let (length (start-pos (stream-column stream)))
  153.                     (princ arg stream)
  154.                     (setq length (- (stream-column stream) start-pos))
  155.                     (if (< length 0) (setq length 0))
  156.                     (dotimes (i minpad) (write-char padchar stream))
  157.                      (incf length minpad)
  158.                     (do ()
  159.                         ((>= length mincol))
  160.                         (dotimes (i colinc) (write-char padchar stream))
  161.                         (incf length colinc)))))
  162.             (1+ index)))
  163.  
  164. (%set-format-dispatch-func #\S 
  165.     #'(lambda (stream args index atsign-modifier colon-modifier control
  166.                 &optional mincol colinc 
  167.                         minpad padchar)
  168.         (setq args (nthcdr index args))
  169.         (if (null args) 
  170.             (error "Not enough args for ~AS format directive" #\~))
  171.  
  172.         ;; initialize defaults
  173.         (unless mincol (setq mincol 0))
  174.         (unless colinc (setq colinc 1))
  175.         (unless minpad (setq minpad 0))
  176.         (setq padchar (if padchar (int-char padchar) #\Space))
  177.  
  178.         (let ((*print-escape* t)
  179.                 (arg (car args)))
  180.             (if (and (null arg) colon-modifier)
  181.                 (setq arg "()"))
  182.             (if atsign-modifier
  183.                 ;; need to output to string to insert padding in front
  184.                 (let ((s (with-output-to-string (x) (prin1 arg x))) 
  185.                       length)
  186.                     (dotimes (i minpad) (write-char padchar stream))
  187.                     (setq length (length s))
  188.                      (incf length minpad)
  189.                     (do ()
  190.                         ((>= length mincol))
  191.                         (dotimes (i colinc) (write-char padchar stream))
  192.                         (incf length colinc))
  193.                     (princ s stream))
  194.                 (let (length (start-pos (stream-column stream)))
  195.                     (prin1 arg stream)
  196.                     (setq length (- (stream-column stream) start-pos))
  197.                     (if (< length 0) (setq length 0))
  198.                     (dotimes (i minpad) (write-char padchar stream))
  199.                      (incf length minpad)
  200.                     (do ()
  201.                         ((>= length mincol))
  202.                         (dotimes (i colinc) (write-char padchar stream))
  203.                         (incf length colinc)))))
  204.             (1+ index)))
  205.  
  206. (%set-format-dispatch-func #\D 
  207.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  208.                 &optional mincol padchar commachar)
  209.         (setq args (nthcdr index args))
  210.         (if (null args) 
  211.             (error "Not enough args for ~~D format directive"))
  212.  
  213.         ;; if not an integer use ~A output
  214.         (if (not (integerp (car args)))
  215.             (let ((*print-base* 10))
  216.                 (return (apply (%get-format-dispatch-func #\A)
  217.                         stream args atsign-modifier
  218.                         colon-modifier mincol nil nil padchar))))
  219.  
  220.         (%format-integer stream (car args) 10 atsign-modifier colon-modifier
  221.                 mincol padchar commachar)
  222.         (1+ index)))
  223.  
  224. (%set-format-dispatch-func #\B 
  225.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  226.                 &optional mincol padchar commachar)
  227.         (setq args (nthcdr index args))
  228.         (if (null args) 
  229.             (error "Not enough args for ~AB format directive" #\~))
  230.  
  231.         ;; if not an integer use ~A output
  232.         (if (not (integerp (car args)))
  233.             (let ((*print-base* 2))
  234.                 (return (apply (%get-format-dispatch-func #\A)
  235.                         stream args atsign-modifier
  236.                         colon-modifier mincol nil nil padchar))))
  237.  
  238.         (%format-integer stream (car args) 2 atsign-modifier colon-modifier
  239.                 mincol padchar commachar)
  240.         (1+ index)))
  241.  
  242. (%set-format-dispatch-func #\O 
  243.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  244.                 &optional mincol padchar commachar)
  245.         (setq args (nthcdr index args))
  246.         (if (null args) 
  247.             (error "Not enough args for ~AO format directive" #\~))
  248.  
  249.         ;; if not an integer use ~A output
  250.         (if (not (integerp (car args)))
  251.             (let ((*print-base* 8))
  252.                 (return (apply (%get-format-dispatch-func #\A)
  253.                         stream args atsign-modifier
  254.                         colon-modifier mincol nil nil padchar))))
  255.  
  256.         (%format-integer stream (car args) 8 atsign-modifier colon-modifier
  257.                 mincol padchar commachar)
  258.         (1+ index)))
  259.  
  260. (%set-format-dispatch-func #\X 
  261.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  262.                 &optional mincol padchar commachar)
  263.         (setq args (nthcdr index args))
  264.         (if (null args) 
  265.             (error "Not enough args for ~AX format directive" #\~))
  266.  
  267.         ;; if not an integer use ~A output
  268.         (if (not (integerp (car args)))
  269.             (let ((*print-base* 16))
  270.                 (return (apply (%get-format-dispatch-func #\A)
  271.                         stream args atsign-modifier
  272.                         colon-modifier mincol nil nil padchar))))
  273.  
  274.         (%format-integer stream (car args) 16 atsign-modifier colon-modifier
  275.                 mincol padchar commachar)
  276.         (1+ index)))
  277.  
  278. (%set-format-dispatch-func #\R 
  279.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  280.                 &optional radix mincol padchar commachar)
  281.         (setq args (nthcdr index args))
  282.         (if (null args) 
  283.             (error "Not enough args for ~AR format directive" #\~))
  284.         
  285.         (if radix
  286.             ;; if not an integer use ~A output
  287.             (progn
  288.                 (if (not (integerp (car args)))
  289.                     (let ((*print-base* radix))
  290.                         (return (apply (%get-format-dispatch-func #\A)
  291.                                     args atsign-modifier
  292.                                     colon-modifier mincol nil nil padchar))))
  293.                 (unless (and (plusp radix) (<= radix 36))
  294.                     (error "Invalid radix specified: ~A" radix))
  295.                 (%format-integer stream (car args) radix atsign-modifier colon-modifier
  296.                     mincol padchar commachar))
  297.             (progn
  298.                 (if (not (integerp (car args)))
  299.                     (return (apply (%get-format-dispatch-func #\A)
  300.                                     args atsign-modifier
  301.                                     colon-modifier mincol nil nil padchar)))
  302.                 (cond
  303.                     ((and atsign-modifier colon-modifier) 
  304.                       (%format-old-roman-numeral (car args) stream))
  305.                     (atsign-modifier (%format-roman-numeral (car args) stream))
  306.                     (colon-modifier (%format-ordinal-number (car args) stream))
  307.                     (t (%format-cardinal-number (car args) stream)))))
  308.         (1+ index)))
  309.  
  310. (%set-format-dispatch-func #\~ 
  311.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  312.                 &optional num)
  313.         (unless num (setq num 1))
  314.         (dotimes (i num)
  315.             (write-char #\~ stream))
  316.         index))
  317.  
  318. (%set-format-dispatch-func #\% 
  319.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  320.                 &optional num)
  321.         (unless num (setq num 1))
  322.         (dotimes (i num)
  323.             (write-char #\Newline stream))
  324.         index))
  325.  
  326. (%set-format-dispatch-func #\F 
  327.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  328.                 &optional width digits scale overflow-char padchar)
  329.         (setq args (nthcdr index args))
  330.         (if (null args) 
  331.             (error "Not enough args for ~~F format directive"))
  332.  
  333.         ;; initialize defaults
  334.         (unless width (setq width -1))
  335.         (unless digits (setq digits 1))
  336.         (unless scale (setq scale 0))
  337.         (setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
  338.         (setq padchar (if padchar (int-char padchar) #\Space))
  339.  
  340.         (print-float (car args) stream :fixed width digits
  341.                 scale padchar atsign-modifier)
  342.         (1+ index)))
  343.  
  344. (%set-format-dispatch-func #\G 
  345.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  346.                 &optional width digits exp-digits scale overflow-char padchar
  347.                     exponent-char)
  348.         (setq args (nthcdr index args))
  349.         (if (null args) 
  350.             (error "Not enough args for ~~G format directive"))
  351.  
  352.         ;; initialize defaults
  353.         (unless width (setq width -1))
  354.         (unless digits (setq digits 1))
  355.         (unless exp-digits (setq exp-digits 2))
  356.         (unless scale (setq scale 0))
  357.         (setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
  358.         (setq padchar (if padchar (int-char padchar) #\Space))
  359.         (setq exponent-char (if exponent-char (int-char exponent-char) #\E))
  360.  
  361.         (print-float (car args) stream :general width digits
  362.                 scale padchar atsign-modifier)
  363.         (1+ index)))
  364.  
  365. (%set-format-dispatch-func #\E 
  366.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  367.                 &optional width digits exp-digits scale overflow-char padchar
  368.                     exponent-char)
  369.         (setq args (nthcdr index args))
  370.         (if (null args) 
  371.             (error "Not enough args for ~~E format directive"))
  372.  
  373.         ;; initialize defaults
  374.         (unless width (setq width -1))
  375.         (unless digits (setq digits 1))
  376.         (unless exp-digits (setq exp-digits 2))
  377.         (unless scale (setq scale 0))
  378.         (setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
  379.         (setq padchar (if padchar (int-char padchar) #\Space))
  380.         (setq exponent-char (if exponent-char (int-char exponent-char) #\E))
  381.  
  382.         (print-float (car args) stream :exponential width digits
  383.                 scale padchar atsign-modifier)
  384.         (1+ index)))
  385.  
  386. (%set-format-dispatch-func #\{ 
  387.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  388.         (setq args (nthcdr index args))
  389.         (unless args 
  390.             (error "Not enough args for ~~{ format directive"))
  391.         (unless (or (listp (car args)) atsign-modifier)
  392.             (error "Invalid format argument--should be a list"))
  393.  
  394.         (let ((end-brace-index (search "~}" (car control) :start2 (cadr control)))
  395.               string)
  396.             (if end-brace-index
  397.                 (setq string (subseq (car control) (cadr control) end-brace-index))
  398.                 (error "Missing ~~} following ~{ in format string"))
  399.             (setf (cadr control) (+ 2 end-brace-index))
  400.             (cond 
  401.                 ((and colon-modifier atsign-modifier)
  402.                     (return 
  403.                         (do ((arg-index 0))
  404.                             ((>= arg-index (length args)) (+ index arg-index))
  405.                             (%format-list stream string (nth arg-index args))
  406.                             (incf arg-index))))
  407.                 (colon-modifier
  408.                     (return
  409.                         (do ((arg-index 0))
  410.                             ((>= arg-index (length (car args))) (1+ index))
  411.                             (%format-list stream string (nth arg-index (car args)))
  412.                             (incf arg-index))))
  413.                 (atsign-modifier                     
  414.                     (return 
  415.                         (do ((arg-index 0))
  416.                             ((>= arg-index (length args)) (+ index arg-index))
  417.                             (incf arg-index 
  418.                                 (%format-list stream string (nthcdr arg-index args))))))
  419.                 (t 
  420.                     (catch '%format-up-and-out
  421.                         (do ((arg-index 0))
  422.                             ((>= arg-index (length (car args))) (1+ index))
  423.                             (incf arg-index 
  424.                                 (%format-list stream string 
  425.                                     (nthcdr arg-index (car args))))))
  426.                     (1+ index))))))
  427.  
  428. (%set-format-dispatch-func #\^
  429.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  430.         (setq args (nthcdr index args))
  431.         (unless args (throw '%format-up-and-out nil))
  432.         index))
  433.  
  434. (%set-format-dispatch-func #\& 
  435.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  436.                 &optional num)
  437.         (unless num (setq num 1))
  438.         (if (>= num 1)
  439.             (progn 
  440.                 (fresh-line stream)
  441.                 (dotimes (i (1- num))
  442.                     (terpri stream))))
  443.         index))
  444.  
  445. (%set-format-dispatch-func #\| 
  446.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  447.                 &optional num)
  448.         (unless num (setq num 1))
  449.         (dotimes (i num)
  450.             (write-char (int-char 12) stream))
  451.         index))
  452.  
  453. (%set-format-dispatch-func #\Newline 
  454.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  455.         ;; if atsign, process the newline
  456.         (if atsign-modifier
  457.             (terpri stream))
  458.         ;; skip whitespace
  459.         (unless colon-modifier
  460.             (do ((c (char (car control) (cadr control)) 
  461.                     (char (car control) (cadr control))))
  462.                 ((not (or (char= c #\Space) (char= c #\Tab))))
  463.                 (incf (cadr control)))
  464.             index)))
  465.  
  466. (%set-format-dispatch-func #\T 
  467.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  468.                 &optional colnum colinc)
  469.         (unless colnum (setq colnum 1))
  470.         (unless colinc (setq colinc 1))
  471.         (if atsign-modifier
  472.             (progn
  473.                 (dotimes (i colnum)
  474.                     (write-char #\Space stream))
  475.                 (dotimes (i (- colinc (mod (stream-column stream) colinc)))
  476.                     (write-char #\Space stream)))
  477.             (let ((current-position (stream-column stream)))
  478.                 (if (> colnum current-position)
  479.                     (dotimes (i (- colnum current-position))
  480.                         (write-char #\Space stream))
  481.                     (if (> colinc 0)
  482.                         (dotimes (i (- colinc (mod (- current-position colnum) colinc)))
  483.                             (write-char #\Space stream))))))
  484.         index))
  485.  
  486. (%set-format-dispatch-func #\* 
  487.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  488.                 &optional num)
  489.         (unless num (if atsign-modifier (setq num 0) (setq num 1)))
  490.         (if atsign-modifier
  491.             (return num))
  492.         (if colon-modifier (return (- index num)))
  493.         (return (+ index num))))
  494.  
  495. (defun %format-integer (stream int radix atsign-modifier colon-modifier 
  496.                 mincol padchar commachar)
  497.  
  498.         ;; initialize defaults
  499.         (unless mincol (setq mincol 0))
  500.         (setq padchar (if padchar (int-char padchar) #\Space))
  501.         (setq commachar (if commachar (int-char commachar) #\,))
  502.  
  503.         (let ((*print-base* radix)
  504.               (*print-radix* nil)
  505.               s
  506.               (length 0)
  507.               sign)
  508.  
  509.             (if (and atsign-modifier (plusp int))
  510.                 (progn (setf sign #\+) (incf length))
  511.                 (if (minusp int)
  512.                     (progn (setf sign #\-) (incf length) (setf int (- int)))))
  513.  
  514.             (setq s (with-output-to-string (x) (princ int x)))
  515.             (incf length (length s))
  516.             (if colon-modifier 
  517.                 (incf length (truncate (1- (length s)) 3)))
  518.             (if (< length mincol)
  519.                 (dotimes (i (- mincol length))
  520.                     (write-char padchar stream)))
  521.  
  522.             (if sign (write-char sign stream))
  523.  
  524.             (if colon-modifier
  525.                 (dotimes (i (length s))
  526.                     (write-char (char s i) stream)
  527.                     (let* ((digits-left (- (length s) (1+ i)))
  528.                            (digit-pos (mod digits-left 3)))
  529.                         (if (and (zerop digit-pos) (plusp digits-left))
  530.                             (write-char commachar stream))))
  531.                 (princ s stream))))  
  532.  
  533. (defconstant *format-cardinals*
  534.     #("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten"
  535.       "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety" "hundred"
  536.       "thousand" "million" "billion" "trillion"))
  537.  
  538. (defun %format-cardinal-number (int stream)
  539.         (if (zerop int) (return (princ "zero" stream)))
  540.         (if (minusp int) 
  541.             (progn (princ "negative " stream) (setq int (- int))))
  542.         (cond
  543.             ((< int 20)
  544.              (princ (nth int '("zero" "one" "two" "three" "four" "five" 
  545.                     "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
  546.                     "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) 
  547.                 stream))
  548.             ((< int 100)
  549.              (princ (nth (- (truncate int 10) 2) '("twenty" "thirty" "forty"
  550.                             "fifty" "sixty" "seventy" "eighty" "ninety")) stream)
  551.              (if (plusp (mod int 10)) 
  552.                 (progn 
  553.                     (write-char #\- stream)
  554.                     (%format-cardinal-number (mod int 10) stream))))
  555.             ((< int 1000)
  556.              (%format-cardinal-number (truncate int 100) stream)
  557.              (princ " hundred" stream)
  558.              (if (plusp (mod int 100))
  559.                 (progn    
  560.                     (write-char #\Space stream)         
  561.                     (%format-cardinal-number (mod int 100) stream))))
  562.             ((< int 1000000)
  563.              (%format-cardinal-number (truncate int 1000) stream)
  564.              (princ " thousand" stream)
  565.              (if (plusp (mod int 1000))
  566.                 (progn    
  567.                     (write-char #\Space stream)         
  568.                     (%format-cardinal-number (mod int 1000) stream))))
  569.             ((< int 1000000000)
  570.              (%format-cardinal-number (truncate int 1000000) stream)
  571.              (princ " million" stream)
  572.              (if (plusp (mod int 1000000))
  573.                 (progn    
  574.                     (write-char #\Space stream)         
  575.                     (%format-cardinal-number (mod int 1000000) stream))))
  576.             (t (princ "billions"))))
  577.  
  578. (defun %format-ordinal-number (int stream)
  579.     (princ "Sorry" stream))
  580.  
  581. (defun %format-roman-numeral (int stream)
  582.     (princ "Sorry" stream))
  583.  
  584. (defun %format-old-roman-numeral (int stream)
  585.     (princ "Sorry" stream))
  586.  
  587.  
  588.  
  589.  
  590.  
  591.  
  592.  
  593.  
  594.  
  595.  
  596.  
  597.  
  598.  
  599.